home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Games of Daze
/
Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso
/
x2ftp
/
msdos
/
source
/
swags-z
/
sorting.swg
/
0003_ANAGRAM2.PAS.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-05-28
|
16KB
|
414 lines
{ ANAGRAM. --------------------------------------------------------------------
Raphaël Vanney, 01/93
Purpose : Reads a list of Words 4 to 10 Characters long from a File
named 'LIST.#1', outputs a list of anagrams founds in a
specified format to a File named 'ANAGRAM.RES'.
Note : I commented-out the source using a langage, say English, which
I'm not Really fluent in ; please forgive mistakes.
------------------------------------------------------------------------------}
{$m 8192,65536,655360}
{$a+,d+,e-,f-,g+,i+,l+,n-,o-,q-,r-,s-,v+}
{$b-} { Turns off complete Boolean evaluation ; this allows easiest
combined Boolean tests. }
Uses Crt,
Objects ;
Const
MaxWordLen = 10 ; { Offically specified by GP ! }
CntAnagrams : Word = 0 ; { Actually, this counter shows the }
{ number of Words found in the }
{ output File. }
OutFileName = 'ANAGRAM.RES' ;
Type TWordString = String[MaxWordLen] ;
{ TWordCollection.
This Object will be used to store the Words in a sorted fashion. As
long as the input list is already sorted, it could have inherited
from TCollection, put there is no big penalty using a sorted one. }
TWordCollection =
Object (TSortedCollection)
Function KeyOf(Item : Pointer) : Pointer ; Virtual ;
Function Compare(Key1, Key2 : Pointer) : Integer ; Virtual ;
Procedure FreeItem(Item : Pointer) ; Virtual ;
end ;
PWordCollection = ^TWordCollection ;
{ TWord.
This is the Object we'll use to store a Word. Each Word knows :
- it's 'Textual form' : It
- the first of it's anagrams, if it has been found to be the
anagram of another Word,
- the next of it's anagrams, in the same condition. }
PWord = ^TWord ;
TWord =
Object
It : TWordString ;
FirstAng : PWord ;
NextAng : PWord ;
Constructor Init(Var Wrd : TWordString) ;
Destructor Done ;
end ;
Var WordsList : PWordCollection ; { The main list of Words }
OrgMem : LongInt ; { Original MemAvail }
UsedMem : LongInt ; { Amount of RAM used }
{-------------------------------------- TWord --------------------------------}
Constructor TWord.Init ;
begin
It:=Wrd ;
FirstAng:=Nil ;
NextAng:=Nil ;
end ;
Destructor TWord.Done ;
begin
end ;
{-------------------------------------- TWordCollection ----------------------}
{ The following methods are not commented out, since they already are in
Turbo-Pascal's documentations, and they do nothing unusual. }
Function TWordCollection.KeyOf ;
begin
KeyOf:=Addr(PWord(Item)^.It) ;
end ;
Function TWordCollection.Compare ;
Var k1 : PString Absolute Key1 ;
k2 : PString Absolute Key2 ;
begin
If k1^>k2^
Then Compare:=1
Else If k1^<k2^
Then Compare:=-1
Else Compare:=0 ;
end ;
Procedure TWordCollection.FreeItem ;
begin
Dispose(PWord(Item), Done) ;
end ;
{-------------------------------------- Utilities ----------------------------}
Procedure CleanUp(Var Wrd : TWordString) ;
{ Cleans-up a Word, in Case there would be dirty Characters in the input File }
Var i : Integer ;
begin
{ Removes trailing spaces ; not afraid of empty Strings }
While Wrd[Length(Wrd)]=' ' Do Dec(Wrd[0]) ;
{ Removes any suspect Character }
i:=1 ;
While (i<=Length(Wrd)) Do
begin
If Wrd[i]<#33 Then Delete(Wrd, i, 1)
Else Inc(i) ;
end ;
end ;
Function PadStr(St : TWordString ; Len : Integer) : String ;
{ Returns a String padded With spaces, of the specified length }
Var i : Integer ;
Tmp : String ;
begin
Tmp:=St ;
For i:=Length(Tmp)+1 To Len Do Tmp[i]:=' ' ;
Tmp[0]:=Chr(Len) ;
PadStr:=Tmp ;
end ;
{-----------------------------------------------------------------------------}
Function AreAnagrams(Var WordA, WordB : TWordString) : Boolean ;
{ Tells whether two Words are anagrams of each other ; assumes the Words
are 'clean' (No Up/Low Case checking, no dirty Characters...)
Optimizing hint : Passing parameters by address _greatly_ enhances overall
speed ; anyway, we'll use a local copy of one of the two, since the used
algorithms needs to modify one of the two Words. }
Assembler ;
Var WordC : TWordString ; { Local copy of WordB }
Asm
Push DS { Let's save the Data segment... }
LDS SI, WordA { Load WordA's address in ES:DI }
Mov AL, [SI] { Load length Byte into AL }
LDS SI, WordB { Load WordB's address }
Cmp AL, [SI] { Compare lengthes }
JNE @NotAng { <>lengthes, not anagrams }
LDS SI, WordB
{ Let's make a local copy of WordB ; enhanced version of TP's "Move" }
ClD { Clear direction flag }
Push SS
Pop ES { Segment part of WordC's address }
LEA DI, WordC { Offset part of it }
Mov CL, DS:[SI] { Get length Byte }
XOr CH, CH { Make it a Word }
Mov DL, CL { Save length For later use }
Inc CX { # of Bytes to store the String }
ShR CX, 1 { We'll copy Words ; CF is importt }
Rep MovSW { Copy WordB to WordC }
JNC @NoByte
MovSB { Copy last Byte }
@NoByte:
LDS SI, WordA { DS:SI contains WordA's address }
Inc SI { SI points to first Char of WordA }
Mov DH, DL { Use DH as a loop counter }
LEA BX, WordC { Load offset of WordC in BX }
Inc BX { Skip length Byte }
{ For each letter in WordA, search it in WordB ; if found, mark it as
'used' in WordB, then proceed With next.
If a letter is not found, Words are not anagrams ; if all are
found, Words are anagrams. }
{ Registers usage :
AL : scratch For SCAS
AH : unused
BX : offset part of WordC's address
CX : will be used as a counter For SCAS
DL : contains length of Strings ; 'll be used to reset CX
DH : loop counter ; initially =DL
ES : segment part of WordC's address
DI : scratch For SCAS
DS:SI : Pointer to next Char to process in WordA
}
@Bcle:
LodSB { Load next Char of WordA in AL }
Mov CL, DL { Load length of String in CX }
Mov DI, BX { Copy offset of WordC to DI }
RepNE ScaSB { Scan WordC For AL 'till found }
JNE @NotAng { Char not found, not anagrams }
Dec DI { Back-up to matching Char }
Mov Byte Ptr ES:[DI], '*' { Mark the Character as 'used' }
Dec DH { Dec loop counter }
Or DH, DH { Done all Chars ? }
JNZ @Bcle { No, loop }
{ All Chars done, the Words are anagrams }
Mov AL, 1 { Result=True }
Or AL, AL { Set accordingly the ZF }
Jmp @Done
@NotAng:
XOr AL, AL { Result=False }
@Done:
Pop DS { Restore DS }
end ;
Function ReadWordsFrom(FName : String) : Boolean ;
Var InF : Text ; { Input File }
Buf : Array[1..2048] Of Byte ; { Speed-up Text buffer }
Lig : String ; { Read line }
Wrd : String ; { Word gotten from parsed Lig }
WSt : TWordString ; { Checked version of Wrd }
p : Integer ; { Work }
Cnt : LongInt ; { Line counter }
begin
ReadWordsFrom:=False ; { 'till now, at least ! }
WordsList:=New(PWordCollection, Init(20, 20)) ;
Assign(InF, FName) ;
{$i-}
ReSet(InF) ;
{$i+}
If IOResult<>0 Then Exit ;
SetTextBuf(InF, Buf, SizeOf(Buf)) ;
Cnt:=0 ;
While Not EOF(InF) Do
begin
Inc(Cnt) ;
ReadLn(InF, Lig) ;
While Lig<>'' Do
begin
{ Let's parse the read line into Words }
p:=Pos(',', Lig) ;
If p=0 Then p:=Length(Lig)+1 ;
Wrd:=Copy(Lig, 1, p-1) ;
{ Check of overflowing Word length }
If Length(Wrd)>MaxWordLen Then
WriteLn('Word length > ', MaxWordLen, ' : ', Wrd) ;
WSt:=Wrd ;
CleanUp(WSt) ;
If WSt<>'' Then WordsList^.Insert(New(PWord, Init(WSt))) ;
Delete(Lig, 1, p) ;
end ;
end ;
{$i-}
Close(InF) ;
{$i+}
If IOResult<>0 Then ;
ReadWordsFrom:=True ;
WriteLn(Cnt, ' lines, ', WordsList^.Count, ' Words found.') ;
end ;
Procedure CheckAnagrams(i : Integer) ;
{ This Procedure builds, if necessary (i.e. not already done), the anagrams
list For Word #i of the list. }
Var Org : PWord ; { Original Word (1st of list) }
j : Integer ; { Work }
Last : PWord ; { Last anagram found }
begin
Org:=WordsList^.Items^[i] ;
If Org^.FirstAng<>Nil Then
begin
{ This Word is already known to be the anagram of at least another
one ; don't re-do the job. }
{ _or_ this Word is known to have no anagrams in the list }
Exit ;
end ;
{ Search anagrams }
Last:=Org ;
Org^.FirstAng:=Org ; { This Word is the first of it's }
{ own anagrams list ; normal, no ? }
For j:=Succ(i) To Pred(WordsList^.Count) Do
{ Don't search the begining of the list, of course ! }
begin
{ Let's skip anagram checking if lengths are <> }
If Org^.It[0]=PWord(WordsList^.Items^[j])^.It[0] Then
If AreAnagrams(Org^.It, PWord(WordsList^.Items^[j])^.It) Then
begin
{ Build chained list of anagrams }
Last^.NextAng:=WordsList^.Items^[j] ;
Last:=WordsList^.Items^[j] ;
Last^.FirstAng:=Org ;
end ;
end ;
Last^.NextAng:=Nil ; { Unusefull, but keep carefull }
end ;
Procedure ScanForAnagrams ;
{ This Procedure scans the list of Words For anagrams, and do the outputing
to the 'ANAGRAM.RES' File. }
Var i : Integer ; { Work }
Tmp : PWord ; { Temporary Word }
Out : Text ; { Output File }
Comma : Boolean ; { Helps dealing With commas }
Current : PWord ; { Currently handled Word }
begin
Assign(Out, OutFileName) ;
ReWrite(Out) ;
With WordsList^ Do
For i:=0 To Pred(Count) Do
begin
Current:=Items^[i] ;
CheckAnagrams(i) ;
{ We're now gonna scan the chained list of known anagrams for
this Word. }
If (Current^.NextAng<>Nil) Or (Current^.FirstAng<>Current) Then
{ This Word has at least an anagram other than itself }
begin
Write(Out, PadStr(Current^.It, 12)) ;
Inc(CntAnagrams) ;
Comma:=False ;
Tmp:=Current^.FirstAng ;
While Tmp<>Nil Do
begin
If Tmp<>Current Then { Don't reWrite it... }
begin
If Comma Then Write(Out, ', ') ;
Comma:=True ;
Write(Out, Tmp^.It) ;
Inc(CntAnagrams) ;
end ;
Tmp:=Tmp^.NextAng ;
end ;
WriteLn(Out) ;
end ;
end ;
Close(Out) ;
end ;
Var Tmp : LongInt ;
begin
{ Check command line parameter }
If ParamCount<>1 Then
begin
WriteLn('Anagram. Raphaël Vanney, 01/93 - Anagram''s contest entry.');
WriteLn ;
WriteLn('Anagram <input_File>') ;
WriteLn ;
WriteLn('Please specify input File name.') ;
Halt(1) ;
end ;
OrgMem:=MemAvail ;
{ Read Words list from input File }
If Not ReadWordsFrom(ParamStr(1)) Then
begin
WriteLn('Error reading Words from input File.') ;
Halt(1) ;
end ;
{ Display statistics stuff }
WriteLn('Reading and sorting done.') ;
UsedMem:=OrgMem-MemAvail ;
WriteLn('Used RAM : ', UsedMem, ' Bytes') ;
Tmp := Trunc(1.0 * MemAvail / (1.0 * UsedMem / WordsList^.Count)) ;
If Tmp > 16383 Then
Tmp := 16383 ;
WriteLn('Potential Words manageable : ', Tmp) ;
{ Scan For anagrams, create output File }
ScanForAnagrams ;
WriteLn('Anagrams scanning & output done.') ;
WriteLn(CntAnagrams, ' Words written to ', OutFileName) ;
{ Clean-up }
Dispose(WordsList, Done) ;
end.
{
------------------------------------------------------------------------------
Okay, this is my entry For the 'anagram contest' !
The few things I'd like to point-out about it :
. I chosed to use OOP, in contrast to seeking speed. I wouldn't say my
Program is Really slow (7.25 secs on my 386-33), but speed was not my
first concern.
. It fully Uses one of the interresting points of OOP in TP, i.e.
reusability, through inheritance,
. When a Word (A) has been found to be an anagram of another (B), the
Program never searches again For the anagrams of (A) ; this
highly reduces computing time... but I believe anybody does the same.
. I also quite like the assembly langage Function 'AreAnagrams'.
------------------------------------------------------------------------------
The Words list is stored in memory in the following maner :
. A collection (say, a list) of the Words,
. Within this list, anagrams are chained as a list
. Each Word knows the first and the next of its anagrams
------------------------------------------------------------------------------
For the sake of speed, I did something I'm quite ashamed of ; but it
saves 32% of execution time, so...
The usual way to access element #i of a TCollection is to call Function At
with parameter i (i.e. At(i)) ; there is also another way, which is not Really
clean, but which I chosed to use : access it directly through Items^[i].
